home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / PBCRT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  31KB  |  1,026 lines
  1. {SECTION ..PbCRT }
  2. UNIT PbCRT;
  3.  
  4. INTERFACE
  5.  
  6. uses DOS, CRT, PbMISC;
  7.  
  8. {
  9. Description:  Extenstion to CRT unit
  10.  
  11. Author      : Howard Richoux
  12. Date        : 2/22/91
  13. Last revised: 12/11/93 fixes
  14.                        GetKeyInput - added
  15.               1/9/94   Sectioned and Sorted
  16.               2/8/94   save/restore TEXTATTR
  17.               2/18/94  new libraries
  18.               2/20/94  Re-Wrote to eliminate TUG units
  19.                        Changed SAVE procedures to just save the current window
  20.               2/21/94  Merged in HKEYstuf
  21.               4/25/94  added FetchCRTLine(n) and NewSnapShot for screen reading
  22. Application : IBM PC and compatibles, done in Turbo Pascal 5.5
  23. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  24. Published in: none
  25. }
  26. {-}
  27. const ScrnColorSeg   = $B800;  { Text area of color CGA/EGA/VGA }
  28. const ScrnMonoSeg    = $B000;  { Text area of MONO card }
  29. const SaveSigniture  = $1234;  { Unique signiture for already saved }
  30.  
  31. type  savebuf    = array[0..3999] of char;
  32.       savebufptr = ^savebuf;
  33.  
  34. type  CRTSaveRec = record
  35.         signiture           : word;       { set to SaveSigniture when in use }
  36.         scrnsaveptr         : savebufptr; { screen buffer on heap }
  37.         savebufsize         : integer;    { amount actually allocated }
  38.         cursx, cursy        : byte;
  39.         x0,y0,x1,y1,attr    : byte;
  40.         end;
  41.  
  42. var snapshot  : CRTSaveRec;     { for FetchCRTLine }
  43.  
  44.  
  45.  
  46. type proctype = procedure;
  47.  
  48.  
  49. var HKEY_LastTC  : char;      { for processing function key exits }
  50.  
  51.  
  52. var ScrnClr, PrmptClr, DatClr, MptClr, NtrClr : byte;
  53.     SavedAttribute : byte;
  54.  
  55. type charset = set of char;
  56.  
  57.  
  58. {+}
  59. Function InputStr(Y, X : integer; Prompt : string;
  60.               var St : string; l : integer; Fn : char; var TC : char) : boolean;
  61.                   {[CRT] antique routine}
  62.  
  63. Procedure DisplayStr(Y, X : integer; S : string);
  64.                   {[CRT] antique routine}
  65.  
  66.  
  67. Procedure Beep;   {[CRT] sends ctrl-G}
  68.  
  69. Function  CheckYesNo(s : string; default : char) : boolean;
  70.                   {[CRT] prompts with s, returns t/f for Y/N answer}
  71.  
  72. Procedure ColorScheme(n : integer; var Scrn, Prmpt, Dat, Mpt, Ntr : byte);
  73.                   {[CRT] *Internal mostly* sets a selected color scheme }
  74.  
  75. Procedure ClrScrn;
  76.                   {[CRT] clears to ScrnColor  }
  77.  
  78. Procedure DataColor;
  79.                   {[CRT] sets TextAttr to *internal* DataClr  }
  80.  
  81. Procedure DrawBox(x1,y1,x2,y2:integer);
  82.                   {[CRT] obsolete proc - Use SimpleWindow}
  83.  
  84. Procedure EmptyColor;
  85.                   {[CRT] sets TextAttr to *internal* EmptyClr  }
  86.  
  87. Procedure EntryColor;
  88.                   {[CRT] sets TextAttr to *internal* EntryClr  }
  89.  
  90. Function  FetchCRTLine(lin : integer) : string;
  91.                   {[CRT] Fetches line stored in snapshot }
  92.  
  93. Function  FunctionKeyDecode(ch : char) : string;
  94.                   {[CRT] this is called AFTER you know it is a function key }
  95.  
  96. Function  FunctionKeyProcess( var Ch : char; workproc : proctype) : boolean;
  97.                   {[CRT] Get a key and do some work }
  98.  
  99. Procedure GetKeyCmdProcess(var Command : string; workproc : proctype);
  100.                   {[CRT] Special keys ONLY - WORKPROC gets executed repeatedly while waiting}
  101.  
  102. Procedure GetKeyInputProcess(var str,Command : string; workproc : proctype);
  103.                   {[CRT] ALL KEYS - WORKPROC gets executed repeatedly while waiting}
  104.  
  105. Procedure GetKeyCmd(var Command : string);
  106.                   {[CRT] Special keys ONLY }
  107.  
  108. Procedure GetKeyInput(var str,Command : string);
  109.                   {[CRT] ALL KEYS }
  110.  
  111. Procedure MakeBox(x1,y1,x2,y2:integer);
  112.                   {[CRT] thrilling}
  113.  
  114. Procedure NewSnapShot;
  115.                   {[CRT] Clears old snapshot and takes new one }
  116.  
  117. Procedure NullProc;
  118.                   {[CRT] Place holder for workproc in keyboard input}
  119.  
  120. Procedure Pause;  {[CRT] waits for keypressed}
  121.  
  122. Procedure PromptColor;
  123.                   {[CRT] sets TextAttr to *internal* PromptClr  }
  124.  
  125. Procedure ReSetNormalVideo;
  126.                   {[CRT] restore them to previous colors }
  127.  
  128. Procedure RestoreAttr;
  129.                   {[CRT] put it back before quitting }
  130.  
  131. Procedure RestoreCursor;
  132.                   {[CRT] puts cursor to where it saved it}
  133.  
  134. Procedure RestoreCRT(var CRTSave : CRTSaveRec);
  135.                   {[CRT] You provide the buffer}
  136.  
  137. Procedure SaveAttr;
  138.                   {[CRT] before doing color schemes save original }
  139.  
  140. Procedure SaveCursor;
  141.                   {[CRT] holds cursor position for you}
  142.  
  143. Procedure SaveCRT(var CRTSave : CRTSaveRec);
  144.                   {[CRT] You provide the buffer}
  145.  
  146. Procedure ScrnColor;
  147.                   {[CRT] sets TextAttr to *internal* ScrnClr  }
  148.  
  149. Procedure ScrollDown( NumLines : byte;
  150.                       ULx,ULy,LRx,LRy, DAttr  : byte);
  151.                   {[CRT] DOS call, absolute coordinates}
  152.  
  153. Procedure ScrollUp  ( NumLines : byte;  { Number of lines to scroll }
  154.                       ULx,ULy,LRx,LRy, DAttr  : byte);
  155.                   {[CRT] DOS call, absolute coordinates}
  156.  
  157. Procedure ScrollUpWindow( NumLines : byte;  { Number of lines to scroll }
  158.                           DAttr    : byte); { Display attribute         }
  159.                   {[CRT] scrolls the current WINDOW only}
  160.  
  161. Procedure ScrollDownWindow( NumLines : byte;  { Number of lines to scroll }
  162.                             DAttr    : byte); { Display attribute         }
  163.                   {[CRT] scrolls the current WINDOW only}
  164.  
  165. Procedure SetColorScheme(n : integer);
  166.                   {[CRT] sets color scheme, 0=B/W  1=blues more later }
  167.  
  168. Procedure SetReverseVideo;
  169.                   {[CRT] reverse foreground and background colors }
  170.  
  171. Procedure SimpleWindow(x0,y0,rows,cols : byte; top,bottom : string;
  172.                        var CRTSave : CRTSaveRec);
  173.                    {[CRT] useful window routine }
  174.  
  175.  
  176.  
  177.  
  178. {SECTION .zImplementation }
  179. IMPLEMENTATION
  180.  
  181. var savattr       : integer;
  182. var xxsave,yysave : word;       { local storage for saving cursor }
  183.  
  184.  
  185. {SECTION BakGround  }
  186. Function BakGround(attr : integer) : byte;
  187. var x : integer;
  188.      begin
  189.      BakGround := (attr shr 4) and 7;
  190.      end;
  191.  
  192.  
  193. {SECTION  Beep }
  194. Procedure Beep;
  195.      begin
  196.      write(^G);
  197.      end;
  198.  
  199.  
  200. {SECTION  CheckYesNo }
  201. Function  CheckYesNo(s : string; default : char) : boolean;
  202. var ch : char;
  203.      begin
  204.      CheckYesNo := true;
  205.      if UpCase(default) = 'N' then CheckYesNo := false;
  206.      write(s);
  207.      if UpCase(default) = 'Y' then write(' (Y/n) ')
  208.      else write(' (y/N) ');
  209.      while not keypressed do begin end;
  210.      ch := UpCase(readkey);
  211.      writeln(ch);
  212.      if      ch = 'N' then CheckYesNo := false
  213.      else if ch = 'Y' then CheckYesNo := true;
  214.      end;
  215.  
  216.  
  217.  
  218. {SECTION  DrawBox }
  219. Procedure DrawBox(x1,y1,x2,y2:integer);   {obsolete proc - don't use}
  220.      begin
  221.      CRT.window(1,1,80,25);
  222.      MakeBox(x1,y1,x2,y2);
  223.      CRT.window(x1+1,y1+1,x2-1,y2-1);
  224.      CRT.ClrScr;
  225.      end;
  226.  
  227.  
  228. {SECTION ForGround }
  229. Function ForGround(attr : integer) : byte;
  230.      begin
  231.      ForGround := attr and 15;
  232.      end;
  233.  
  234.  
  235. {SECTION FunctionKeyDecode }
  236. Function FunctionKeyDecode(ch : char) : string;
  237. { this is called AFTER you know it is a function key }
  238. var s : string;
  239.      begin
  240.      s := '';
  241.      case ch of
  242.          'G' : s  := '?HOME';       {HOME}
  243.          'O' : s  := '?END';        {END}
  244.          'Q' : s  := '?DOWN';       {DOWN}
  245.          'I' : s  := '?UP';         {UP}
  246.          'H' : s  := '?UPARR';      {UPArrow}
  247.          'P' : s  := '?DOWNARR';    {DNArrow}
  248.          'K' : s  := '?LEFTARR';    {LeftArrow}
  249.          'M' : s  := '?RIGHTARR';   {RightArrow}
  250.         #114 : s := '?SCREENPR';  {^PrtSc}
  251.  
  252.          ';' : s  := '?FKEY1';        {F1  }
  253.          '<' : s  := '?FKEY2';        {F2  }
  254.          '=' : s  := '?FKEY3';        {F3  }
  255.          '>' : s  := '?FKEY4';        {F4  }
  256.          '?' : s  := '?FKEY5';        {F5  }
  257.          '@' : s  := '?FKEY6';        {F6  }
  258.          'A' : s  := '?FKEY7';        {F7  }
  259.          'B' : s  := '?FKEY8';        {F9  }
  260.          'C' : s  := '?FKEY9';        {F9  }
  261.          'D' : s  := '?FKEY10';       {F10 }
  262.  
  263.          'T' : s  := '?SFKEY1';       {SF1 }
  264.          'U' : s  := '?SFKEY2';       {SF2 }
  265.          'V' : s  := '?SFKEY3';       {SF3 }
  266.          'W' : s  := '?SFKEY4';       {SF4 }
  267.          'X' : s  := '?SFKEY5';       {SF5 }
  268.          'Y' : s  := '?SFKEY6';       {SF6 }
  269.          'Z' : s  := '?SFKEY7';       {SF7 }
  270.          '[' : s  := '?SFKEY8';       {SF9 }
  271.          '\' : s  := '?SFKEY9';       {SF9 }
  272.          ']' : s  := '?SFKEY10';      {SF10}
  273.  
  274.          else  s := '';
  275.          end;
  276.      FunctionKeyDecode := s;
  277.      end;
  278.  
  279.  
  280. {SECTION  FunctionKeyProcess  }
  281. { Formerly HKEYSTUF }
  282. Function  FunctionKeyProcess( var Ch : char; workproc : proctype) : boolean;
  283. var  choice,fkeypressed:     boolean;
  284.     begin
  285.     fkeypressed := false;
  286.     choice := false;
  287.     while not choice do
  288.         begin
  289.         if keypressed then
  290.             begin
  291.             Ch := CRT.ReadKey;
  292.             if Ch = #0 then
  293.                 begin
  294.                 if CRT.keypressed then
  295.                     begin
  296.                     Ch := CRT.ReadKey;
  297.                     fkeypressed := true;
  298.                     end;
  299.                 end;
  300.             choice := true;
  301.             end;
  302.         WorkProc;
  303.         end;
  304.     functionkeyProcess := fkeypressed;
  305.     end;
  306.  
  307.  
  308. {SECTION  GetKeyCmd }
  309. Procedure GetKeyCmd(var Command : string);
  310. var ch    : char;
  311.     done  : boolean;
  312.     CmdString, CmdSave : string;
  313.      BEGIN
  314.      GetKeyCmdProcess(Command,nullproc);
  315.      end;
  316.  
  317.  
  318. {SECTION  GetKeyCmdProcess }
  319. Procedure GetKeyCmdProcess(var Command : string; workproc : proctype);
  320. { Special key input ONLY - no normal text
  321.   WORKPROC gets executed repeatedly while waiting for key input}
  322. var ch    : char;
  323.     done  : boolean;
  324.     CmdString, CmdSave : string;
  325.  
  326.     BEGIN
  327.     CmdString := '';
  328.     done := false;
  329.     while (CmdString = '') and not done do
  330.         begin
  331.         IF FunctionKeyProcess(Ch,workproc) THEN
  332.             BEGIN
  333.             CmdString  := FunctionKeyDecode(ch);
  334.             Ch := ' ';
  335.             END
  336.         else if Ch = #27 then CmdString := '?ESCAPE'
  337.         else if Ch = #13 then CmdString := Command
  338.         else CmdString := '';
  339.         end;
  340.     Command := CmdString;
  341.     end;
  342.  
  343.  
  344. {SECTION  GetKeyInput }
  345. Procedure GetKeyInput(var str,Command : string);
  346. {     Get an input string and a terminating command (like a fkey)}
  347. var ch    : char;
  348.     done  : boolean;
  349.     CmdString, CmdSave : string;
  350.      BEGIN
  351.      GetKeyInputProcess(str,Command,nullproc);
  352.      end;
  353.  
  354.  
  355.  
  356. {SECTION  GetKeyInputProcess }
  357. Procedure GetKeyInputProcess(var str,Command : string; workproc : proctype);
  358. { Special key input AND normal text
  359.   WORKPROC gets executed repeatedly while waiting for key input}
  360. var ch    : char;
  361.     x,y   : byte;
  362.     done  : boolean;
  363.     CmdString, CmdSave : string;
  364.  
  365.     BEGIN
  366.     CmdString := '';
  367.     str       := '';
  368.     done := false;
  369.     while (CmdString = '') and not done do
  370.         begin
  371.         IF FunctionKeyProcess(Ch,workproc) THEN
  372.             BEGIN
  373.             CmdString  := FunctionKeyDecode(ch);
  374.             END
  375.         else if Ch = #27 then CmdString := '?ESCAPE'
  376.         else if Ch = #13 then CmdString := Command  { give back default }
  377.         else if Ch = #8 then   {backspace}
  378.              begin
  379.              if length(str) > 0 then
  380.                   begin
  381.                   x := WhereX; y := WhereY;
  382.                   if x > 1 then dec(x)
  383.                   else begin x := 80; if y>1 then dec(y); end;
  384.                   gotoXY(x,y);
  385.                   write(' ');
  386.                   gotoXY(x,y);
  387.                   delete(str,length(str),1);
  388.                   end
  389.              end
  390.         else begin
  391.              CmdString := '';
  392.              write(ch);
  393.              str := str + ch;
  394.              end;
  395.         end;
  396.     Command := CmdString;
  397.     end;
  398.  
  399.  
  400.  
  401.  
  402. {SECTION  MakeAttr }
  403. Function  MakeAttr(forgnd,bakgnd : integer) : byte;
  404.      begin
  405.      MakeAttr := ((bakgnd and 7) shl 4) or (forgnd and 15);
  406.      end;
  407.  
  408.  
  409.  
  410. {SECTION  MakeBox }
  411. Procedure MakeBox(x1,y1,x2,y2:integer);
  412. const ULcorner = chr(201);
  413.       URcorner = chr(187);
  414.       LLcorner = chr(200);
  415.       LRcorner = chr(188);
  416.       HBAR     = chr(205);
  417.       VBAR     = chr(186);
  418. var i:integer;
  419.      begin
  420.      CRT.highvideo;
  421.      CRT.gotoxy(x1,y1);
  422.      write(ulcorner);
  423.      for i:=x1+1 to x2-1 do write(hbar);
  424.      write(urcorner);
  425.      for i:=y1+1 to y2-1 do
  426.          begin
  427.          CRT.gotoxy(x1,i);      write(vbar);
  428.          CRT.gotoxy(x2,i);      write(vbar);
  429.          end;
  430.      CRT.gotoxy(x1,y2);         write(llcorner);
  431.      for i:=x1+1 to x2-1 do write(hbar);
  432.      write(lrcorner);
  433.      CRT.normvideo;
  434.      end;
  435.  
  436.  
  437. {SECTION  NullProc }
  438. Procedure NullProc;  begin  end;
  439.  
  440.  
  441. {SECTION  Pause }
  442. Procedure Pause;
  443. var ch : char;
  444.      begin
  445.      ch := CRT.readkey;
  446.      end;
  447.  
  448.  
  449. {SECTION  ReSetNormalVideo }
  450. Procedure ReSetNormalVideo;
  451.      begin
  452.      textattr := savattr;
  453.      end;
  454.  
  455.  
  456. {SECTION  RestoreCursor }
  457. Procedure RestoreCursor;
  458.     begin
  459.     CRT.GOTOXY(xxsave,yysave);
  460.     end;
  461.  
  462.  
  463. {SECTION  SaveCursor }
  464. Procedure SaveCursor;
  465.     begin
  466.     xxsave := CRT.wherex;
  467.     yysave := CRT.wherey;
  468.     end;
  469.  
  470.  
  471.  
  472. {SECTION  ScrollDown }
  473. Procedure ScrollDown( NumLines : byte;  { Number of lines to scroll }
  474.                       ULx,ULy,LRx,LRy, DAttr  : byte);
  475.  
  476. const  IntrCall    = 16;   { ROM Video BIOS call        }
  477.        ServiceCall =  7;   { Scroll window down service }
  478.  
  479. var SDDOSRec : Registers;
  480.      begin
  481.      with SDDOSRec do
  482.            begin
  483.            AH := ServiceCall;
  484.            AL := NumLines;
  485.            CH := ULy - 1;
  486.            CL := ULx - 1;
  487.            DH := LRy - 1;
  488.            DL := LRx - 1;
  489.            BH := DAttr
  490.            end; { WITH }
  491.      INTR(IntrCall, SDDOSRec)
  492.      end;  { ScrollDown }
  493.  
  494.  
  495. {SECTION  ScrollUp }
  496. Procedure ScrollUp  ( NumLines : byte;  { Number of lines to scroll }
  497.                       ULx,ULy,LRx,LRy, DAttr  : byte);
  498.  
  499. const  IntrCall    = 16;   { ROM Video BIOS call        }
  500.        ServiceCall =  6;   { Scroll window up service   }
  501.  
  502. var SDDOSRec : Registers;
  503.      begin
  504.      with SDDOSRec do
  505.           begin
  506.           AH := ServiceCall;
  507.           AL := NumLines;
  508.           CH := ULy - 1;
  509.           CL := ULx - 1;
  510.           DH := LRy - 1;
  511.           DL := LRx - 1;
  512.           BH := DAttr
  513.           end; { WITH }
  514.      INTR(IntrCall, SDDOSRec)
  515.      end;  { ScrollUp }
  516.  
  517.  
  518. {SECTION  ScrollUpWindow }
  519. Procedure ScrollUpWindow( NumLines : byte;  { Number of lines to scroll }
  520.                           DAttr    : byte); { Display attribute         }
  521. var x0,y0,x1,y1 : byte;
  522.      begin
  523.      x0 := lo(WindMin)+1;
  524.      y0 := hi(WindMin)+1;
  525.      x1 := lo(WindMax)+1;
  526.      y1 := hi(WindMax)+1;
  527.      ScrollUp(NumLines,x0,y0,x1,y1,Dattr);
  528.      end;
  529.  
  530.  
  531. {SECTION  ScrollDownWindow }
  532. Procedure ScrollDownWindow( NumLines : byte;  { Number of lines to scroll }
  533.                             DAttr    : byte); { Display attribute         }
  534. var x0,y0,x1,y1 : byte;
  535.      begin
  536.      x0 := lo(WindMin)+1;
  537.      y0 := hi(WindMin)+1;
  538.      x1 := lo(WindMax)+1;
  539.      y1 := hi(WindMax)+1;
  540.      ScrollDown(NumLines,x0,y0,x1,y1,Dattr);
  541.      end;
  542.  
  543.  
  544.  
  545. {SECTION  SetReverseVideo }
  546. Procedure SetReverseVideo;
  547.      begin
  548.      savattr := textattr;
  549.      textattr := MakeAttr(BakGround(textattr),ForGround(textattr));
  550.      end;
  551.  
  552.  
  553. {SECTION  SimpleWindow }
  554. Procedure SimpleWindow(x0,y0,rows,cols : byte; top,bottom : string;
  555.                        var CRTSave : CRTSaveRec);
  556. var x1,y1,l : byte;
  557.      begin
  558.      x1 := x0 + cols + 2;
  559.      y1 := y0 + rows + 1;
  560.      CRT.window(x0,y0,x1,y1);
  561.      SaveCRT(CRTSave);
  562.      CRT.window(1,1,80,25);
  563.      MakeBox(x0,y0,x1,y1);
  564.      if top <> '' then
  565.           begin
  566.           l := 1;
  567.           if length(top) < (cols - 2) then
  568.                l := ((x0 + (cols div 2)) - (length(top) div 2)) - 1;
  569.           CRT.gotoxy(l,y0);
  570.           write(top);
  571.           end;
  572.      if bottom <> '' then
  573.           begin
  574.           l := 1;
  575.           if length(bottom) < (cols - 2) then
  576.                l := ((x0 + (cols div 2)) - (length(bottom) div 2)) - 1;
  577.           CRT.gotoxy(l,y1);
  578.           write(bottom);
  579.           end;
  580.      CRT.window(x0+1,y0+1,x1-1,y1-1);
  581.      CRT.clrscr;
  582.      end;
  583.  
  584. {PAGE}
  585. {SECTION  RestoreCRTWindow }
  586. Procedure RestoreCRTWindow(var CRTSave : CRTSaveRec);
  587.        {[CRT] - hard coding for COLOR screen 25x80 - adapt later}
  588. var err,i : integer;
  589.     rows, cols, rowbytes, screenoffset, saveoffset : integer;
  590.     screenptr,saveptr : pointer;
  591.      begin
  592.      screenptr := PTR(ScrnColorSeg,0);
  593.      saveoffset := 0;
  594.      with CRTSave do
  595.           begin
  596.           rows := (y1 - y0) + 1;
  597.           cols := (x1 - x0) + 1;
  598.           rowbytes := cols * 2;   { char + attr }
  599.           savebufsize := rows * cols * 2;
  600.           for i := y0 to y1 do
  601.                begin
  602.                screenoffset := ((i-1) * 160) + (x0 - 1) * 2;
  603.                screenptr := PTR(ScrnColorSeg,screenoffset);
  604.                move(scrnsaveptr^[saveoffset], screenptr^, rowbytes);
  605.                saveoffset   := saveoffset + rowbytes;
  606.                end;
  607.           if savebufsize > 0 then FreeMem(scrnsaveptr,savebufsize);
  608.           savebufsize := 0;
  609.           signiture   := 0;  { mark as not used }
  610.           end;
  611.      end;
  612.  
  613.  
  614.  
  615. {SECTION  SaveCRTWindow }
  616. Procedure SaveCRTWindow(var CRTSave : CRTSaveRec);
  617.        {[CRT] - hard coding for COLOR screen 25x80 - adapt later}
  618. var err,i : integer;
  619.     rows, cols, rowbytes, screenoffset, saveoffset : integer;
  620.     screenptr,saveptr : pointer;
  621.      begin
  622.      if CRTSave.signiture = SaveSigniture then exit;
  623.      screenptr := PTR(ScrnColorSeg,0);
  624.      saveoffset := 0;
  625.      with CRTSave do
  626.           begin
  627.           scrnsaveptr := NIL;
  628.           rows := (y1 - y0) + 1;
  629.           cols := (x1 - x0) + 1;
  630.           rowbytes := cols * 2;   { char + attr }
  631.           savebufsize := rows * cols * 2;
  632.           GetMem(scrnsaveptr,savebufsize);
  633.           signiture := SaveSigniture;  { mark as buffer used }
  634.  
  635.           for i := y0 to y1 do
  636.                begin
  637.                screenoffset := ((i-1) * 160) + (x0 - 1) * 2;
  638.                screenptr := PTR(ScrnColorSeg,screenoffset);
  639.                move(screenptr^,scrnsaveptr^[saveoffset],rowbytes);
  640.                saveoffset   := saveoffset + rowbytes;
  641.                end;
  642.           end;
  643.      end;
  644.  
  645.  
  646.  
  647. {SECTION  RestoreCRT }
  648. Procedure RestoreCRT(var CRTSave : CRTSaveRec);
  649. {var currcurstype       : cursortype;}
  650.      begin
  651.      if CRTSave.signiture <> SaveSigniture then exit;
  652.      with CRTSave do
  653.           begin
  654.           RestoreCRTWindow(CRTSave);
  655.           CRT.window(CRTSave.x0,CRTSave.y0,CRTSave.x1,CRTSave.y1);
  656.           CRT.gotoxy(cursx,cursy);
  657.           TEXTATTR := CRTSave.attr;
  658.          { if currcurstype <> curstype then SetCursor(curstype);}
  659.           end;
  660.      end;
  661.  
  662.  
  663.  
  664. {SECTION  SaveCRT }
  665. Procedure SaveCRT(var CRTSave : CRTSaveRec);
  666.      begin
  667.      if CRTSave.signiture = SaveSigniture then
  668.           begin
  669.           writeln('** already saved ** [',CRTSave.signiture,']');
  670.           exit;
  671.           end;
  672.      with CRTSave do
  673.           begin
  674.           cursx := wherex;
  675.           cursy := wherey;
  676.           x0 := lo(WindMin)+1;
  677.           y0 := hi(WindMin)+1;
  678.           x1 := lo(WindMax)+1;
  679.           y1 := hi(WindMax)+1;
  680.           attr := TEXTATTR;
  681.           SaveCRTWindow(CRTSave);
  682.           end;
  683.      end;
  684.  
  685.  
  686. {SECTION  ClearSaveCRT }
  687. Procedure ClearSaveCRT(var CRTSave : CRTSaveRec);
  688.      begin
  689.      if CRTSave.signiture <> SaveSigniture then exit;
  690.      with CRTSave do
  691.           begin
  692.           if savebufsize > 0 then FreeMem(scrnsaveptr,savebufsize);
  693.           savebufsize := 0;
  694.           signiture   := 0;  { mark as not used }
  695.           cursx := wherex;
  696.           cursy := wherey;
  697.           x0 := lo(WindMin)+1;
  698.           y0 := hi(WindMin)+1;
  699.           x1 := lo(WindMax)+1;
  700.           y1 := hi(WindMax)+1;
  701.           attr := TEXTATTR;
  702.           end;
  703.      end;
  704.  
  705.  
  706. { HKEYstuf merged in (again) 2/21/94 }
  707.  
  708. Procedure ScrnColor;   begin LowVideo;  Textbackground(ScrnClr); end;
  709. Procedure PromptColor; begin Scrncolor; TextColor(PrmptClr); end;
  710. Procedure DataColor;   begin ScrnColor; Textcolor(DatClr); end;
  711. Procedure EmptyColor;  begin ScrnColor; TextBackground(MptClr);TextColor(15); end;
  712. Procedure EntryColor;  begin ScrnColor; TextBackground(NtrClr);TextColor(15); end;
  713. Procedure SaveAttr;    begin SavedAttribute := TextAttr; end;
  714. Procedure RestoreAttr; begin TextAttr := SavedAttribute; end;
  715.  
  716.  
  717. Procedure SetColorScheme(n : integer);
  718.     begin
  719.     ColorScheme(n,ScrnClr,PrmptClr,DatClr,MptClr,NtrClr);
  720.     end;
  721.  
  722.  
  723. Procedure ClrScrn;      begin ScrnColor; CRT.Clrscr; end;
  724.  
  725.  
  726. Procedure ColorScheme(n : integer; var Scrn, Prmpt, Dat, Mpt, Ntr : byte);
  727.      begin
  728.      {Scrn  = basic color of screen
  729.       Prmpt = text color of prompt, background is Screen color
  730.       Dat   = text color for data fields not being entered
  731.       Mpt   = color of whole entry block
  732.       Ntr   = background for text being entered
  733.       }
  734.      case n of
  735.           0     : begin { Gray/black/white }
  736.                   Scrn := 0; Prmpt := 7; Dat := 7; Mpt := 8; Ntr := 8;
  737.                   end;
  738.  
  739.           1     : begin { Blues }
  740.                   Scrn := 3; Prmpt := 9; Dat := 1; Mpt := 9; Ntr := 1;
  741.                   end;
  742.  
  743.           2     : begin { Greens }
  744.                   Scrn := 2; Prmpt :=9; Dat := 1; Mpt :=9; Ntr := 1;
  745.                   end;
  746.  
  747.           3     : begin { Greys }
  748.                   Scrn := 7; Prmpt :=8; Dat := 15; Mpt :=8; Ntr := 15;
  749.                   end;
  750.  
  751.           else    begin { same as #0 }
  752.                   Scrn := 0; Prmpt := 7; Dat := 7; Mpt := 8; Ntr := 8;
  753.                   end;
  754.           end;
  755.      end;
  756.  
  757.  
  758. Procedure ProcessLine;
  759.      begin
  760.      {dummy}
  761.      end;
  762.  
  763.  
  764. Function FunctionKey( var Ch : char ) : boolean;
  765. var choice,fkeypressed:     boolean;
  766.      begin
  767.      fkeypressed := false;
  768.      choice := false;
  769.      while not choice do
  770.           begin
  771.           if keypressed then
  772.                begin
  773.                Ch := ReadKey;
  774.                if Ch = #0 then
  775.                      begin
  776.                      if keypressed then
  777.                           begin
  778.                           Ch := ReadKey;
  779.                           fkeypressed := true;
  780.                           end;
  781.                     end;
  782.                choice := true;
  783.                end;
  784.           Processline;
  785.           end;
  786.      Functionkey := fkeypressed;
  787.      end;
  788.  
  789.  
  790.  
  791. Procedure ReadKbd(VAR Ch : CHAR);
  792.      begin
  793.      if FunctionKey(Ch) then begin end;
  794.      end;
  795.  
  796.  
  797.  
  798. Procedure DisplayStr(Y, X : INTEGER; S : string);
  799.      begin
  800.      if length(S) > (81-X) then S := COPY(S, 1, 81-X);
  801.      GoToXY(X,Y);
  802.      write(S);
  803.      end;
  804.  
  805.  
  806. Function  ConstantCharStr(C : Char; N : Integer) : string;
  807.     { deliberate duplicate of PbMISC routine CONSTSTR }
  808. var S : string;
  809.     begin
  810.     if N < 0 then N := 0;
  811.     S[0] := Chr(N);
  812.     FillChar(S[1],N,C);
  813.     ConstantCharStr := s;
  814.     end;
  815.  
  816.  
  817. {PAGE}
  818. Function InputStr(Y, X : INTEGER;
  819.                       Prompt : string;
  820.                       VAR St : string;
  821.                       L : INTEGER;
  822.                       Fn : CHAR;
  823.                       VAR TC : CHAR) : BOOLEAN;
  824. { Functions: U - Update, A - Append, O - Diaplay only }
  825. CONST   UnderScore = '_';
  826.         Term      : charset = [^E, ^M, ^X, ^Z];
  827.         MinorKeys : charset = [ ^M ];
  828.         Fkeyarrow : charset = ['K', 'M']; { LArr, Rarr}
  829.         FkeyTerm  : charset = ['P', 'H', 'I', 'Q', 'G', 'O'];
  830. VAR                       { DArr,UArr,Home,end,PgUp,PgDn}
  831.         Pl, P : INTEGER;
  832.         S : string;
  833.         Ch : CHAR;
  834.         exitx, firsttime, InsMode, MAJORExit : BOOLEAN;
  835.       begin
  836.       MAJORExit := false;
  837.       firsttime := true; exitx := FALSE; InsMode := true;
  838.       P := 0; Ch := ' ';
  839.  
  840.       PromptColor;
  841.       Pl := length(Prompt);
  842.       if Pl < (X+1) then DisplayStr(Y, X-Pl, Prompt)
  843.       else DisplayStr(Y, 1, COPY(Prompt, Pl-X, X));
  844.  
  845.       EmptyColor;
  846.       GotoXY(X,Y); write(ConstantCharStr(UnderScore, L));
  847.  
  848.       if (Fn = 'O') then
  849.            begin
  850.            S := St;
  851.            DataColor;
  852.            GotoXY(X,Y);
  853.            write(S, ConstantCharStr(UnderScore, L-length(S)));
  854.            end
  855.       else S := '';
  856.  
  857.       if (Fn = 'U') OR (Fn = 'A') then
  858.           begin
  859.           S := '';
  860.           if Fn = 'U' then
  861.                 begin
  862.                 S := St;
  863.                 EmptyColor;
  864.                 GotoXY(X,Y); write(S, ConstantCharStr(UnderScore, L-length(S)));
  865.                 end;
  866.  
  867.            repeat
  868.                 begin
  869.                 GotoXY(X+P,Y);
  870.                 if FunctionKey(Ch) then
  871.                     begin
  872.                     exitx := FALSE;
  873.                     case Ch OF        {* Function keys for field edit operations *}
  874.                         'K' {<-}  : begin
  875.                                     if Fn = 'A' then exitx := true
  876.                                     else if P > 0 then P := P-1 { LArr }
  877.                                     else Beep;
  878.                                     end;
  879.  
  880.                         'M' {->}  : begin
  881.                                     if Fn = 'A' then exitx := true
  882.                                     else if P < length(S) then P := P+1 { RArr }
  883.                                     else Beep;
  884.                                     end;
  885.  
  886.                         'S' {DEL} : begin
  887.                                     if P < length(S) then
  888.                                          begin
  889.                                          delete(S, P+1, 1);
  890.                                          end;
  891.                                      end;
  892.  
  893.                         'R' {INS}: begin
  894.                                    InsMode := not InsMode;
  895.                                    Beep;
  896.                                    end;
  897.  
  898.                         'U'      : begin Beep; Beep; end; { ? }
  899.  
  900.                         else       begin       {* Function keys for exit *}
  901.                                    if not(Ch IN FkeyTerm) then
  902.                                         begin
  903.                                         exitx := TRUE;
  904.                                         if Ch <> ^M then MAJORExit := true;
  905.                                         end;
  906.                                    end;
  907.                         end; {of case}
  908.                     end
  909.                 else
  910.                     begin
  911.                     case Ch OF        {* non Function key operations *}
  912.                         #32..#126 : begin
  913.                                     if firsttime then
  914.                                          begin  {clear rest of default }
  915.                                          S := ''; P := 0;
  916.                                          end;
  917.                                     if not InsMode then
  918.                                          begin  {Overwrite mode }
  919.                                          if {(P > 0) and} (P < length(s)) then
  920.                                               S[P+1] := Ch
  921.                                          else S := S + Ch;
  922.                                          if P < L then P := P + 1;
  923.                                          Ch := ' ';
  924.                                          end
  925.                                     else begin  {Insert mode }
  926.                                          if P < L then
  927.                                               begin
  928.                                               if length(S) = L then
  929.                                                     delete(S, L, 1);
  930.                                               if P < L then P := P+1;
  931.                                               insert(Ch, S, P);
  932.                                               Ch := ' ';
  933.                                               end
  934.                                          else Beep;
  935.                                          end;
  936.                                     end;
  937.  
  938.                         #27 {esc} : begin
  939.                                     exitx := true;
  940.                                     P := 0;
  941.                                     S := '';
  942.                                     end;
  943.  
  944.                         ^S { <- } : if P > 0 then P := P-1
  945.                                     else Beep;
  946.  
  947.                         ^D { -> } : if P < length(S) then P := P+1
  948.                                     else Beep;
  949.  
  950.                         ^A { ^<- }: P := 0;
  951.  
  952.                         ^I { ^-> }: P := length(S);
  953.  
  954.                         ^G {DEL}  : if P < length(S) then
  955.                                          begin
  956.                                          delete(S, P+1, 1);
  957.                                          end;
  958.  
  959.                         ^H, #127  : if P > 0 then  {bkspc}
  960.                                          begin
  961.                                          delete(S, P, 1);
  962.                                          P := P-1;
  963.                                          end
  964.                                     else Beep;
  965.  
  966.                         ^Y {DelEOL}:begin
  967.                                     delete(S, P+1, L);
  968.                                     end;
  969.  
  970.                         else        begin
  971.                                     if not(Ch in Term) then Beep;
  972.                                     end;
  973.                         end; {of case}
  974.                    end; {of if}
  975.                EntryColor;
  976.                GotoXY(X,Y);
  977.                write(S);
  978.                EmptyColor;
  979.                write(ConstantCharStr(UnderScore, L-length(S)));
  980.                GotoXY(X+P,Y);
  981.                firsttime := false;
  982.                end; {of repeat}
  983.           UNTIL (Ch IN Term) OR (Ch IN FkeyTerm) OR exitx;
  984.           St := S;
  985.           TC := Ch;
  986.           if (TC in FKeyTerm) and
  987.             not (TC in MinorKeys) then MAJORExit := true;
  988.           HKEY_LastTC := TC;
  989.           end;{ of Entry Function }
  990.       InputStr := MAJORExit;
  991.       end;
  992.  
  993.  
  994. Procedure NewSnapShot;
  995.           {[CRT] Clears old snapshot and takes new one }
  996.      begin
  997.      ClearSaveCRT(snapshot);
  998.      SaveCRT(snapshot);
  999.      end;
  1000.  
  1001.  
  1002. Function FetchCRTLine(lin : integer) : string;
  1003.       {[CRT] Fetches line stored in snapshot }
  1004. var s   : string;
  1005. var i : integer;
  1006.      begin
  1007.      FetchCRTLine := '';
  1008.      if (lin<1) or (lin>25) then exit;
  1009.      if snapshot.signiture <> SaveSigniture then SaveCRT(snapshot);
  1010.      s := conststr(' ',80);
  1011.      for i := 0 to 79 do
  1012.           begin
  1013.           s[i+1] :=snapshot.scrnsaveptr^[((lin-1)*160)+(i*2)];
  1014.           end;
  1015.      FetchCRTLine := s;
  1016.      end;
  1017.  
  1018.  
  1019. {SECTION  zzInitialization }
  1020.      begin {initialization}
  1021.      savattr := textattr;
  1022.      SetColorScheme(0); {default B/W}
  1023.      HKEY_LastTC := '*';
  1024.      end.
  1025.  
  1026.